|
|
Quickly insert tags for coloring VBA that is posted on web pages and in forums. Color Comments GREEN and Keywords BLUE for VBA.
Since this is just an ACCDB that has been renamed, it is Free and not protected so you can learn.
Open a form to generate colored code for VBA no matter what database you have open.
Choose the type of tags you want, paste the code to tag, and copy the result to the Windows clipboard or generate a file with the resulting code with tags.
Choose what format you want for the tags. Modify tags to be inserted:
Copy the result code to the Windows clipboard.
Create or modify file with code results. There is no prompt for filename. You can modify this to browse and choose your own filename. By default, files will be created in the CurrentDb path.
If you chose to color keywords blue, then they were counted too. The query shows what keywords your code uses, and what it uses most.
This has NOTHING to do with coloring code ... just threw it in since I always run it. And until I make an Add-in with utilities like this, it will save me some time.
VBA > Table > SetSubDatasheetNone http://msaccessgurus.com/VBA/Code/table_SetSubDatasheetNone.htm
Color Code is now on the Add-ins menu.
Option Compare Database Option Explicit '*************** Code Start ***************************************************** ' download: ' http://msaccessgurus.com/tool/Addin_ColorCode.htm ' code behind form: f_ColorCODE_s4p '------------------------------------------------------------------------------- ' Purpose : COLOR CODE: Comments Green and, optionally, Keywords Blue ' Author : crystal (strive4peace) ' License : below code ' Tool List: www.msaccessgurus.com/tools.htm 'needs module: ' mod_SaveStringAsFile ' http://msaccessgurus.com/VBA/Code/File_SaveStringAsFile.htm ' mod_SetSubDatasheetNone (not needed to color code -- extra button in form footer) ' http://msaccessgurus.com/VBA/Code/table_SetSubDatasheetNone.htm 'TABLEs: ' s4p_Code one record is used over and over. ' future: option to save and name code, store in another BE ' s4p_KeyWords is keywords + count how many times they're used in last analysis ' s4p_Sets for sets of tags to use such as BBCode or HTML 'query for SetID combo: ' qSets Dim mbLoad As Boolean '------------------------------------------------------------------------------- ' Form_Load '------------------------------------------------------------------------------- Private Sub Form_Load() '200410 strive4peace 'clear old data Me.codeOrig = Null Me.codeResult = Null mbLoad = True Call SetID_AfterUpdate End Sub '------------------------------------------------------------------------------- ' SetID_AfterUpdate '------------------------------------------------------------------------------- Private Sub SetID_AfterUpdate() '200426 strive4peace, 2112069 chkAddBR With Me.SetID If IsNull(.Value) Then Exit Sub 'get default tags to write for this setting Me.TagCode1 = Nz(.Column(2), "") Me.TagCode2 = Nz(.Column(3), "") Me.TagComment1 = Nz(.Column(4), "") Me.TagComment2 = Nz(.Column(5), "") Me.TagKeyword1 = Nz(.Column(6), "") Me.TagKeyword2 = Nz(.Column(7), "") Me.chkAddBR = (Nz(.Column(10), "0") <> "0") End With 'don't update result when form is loading If Not mbLoad Then Call codeOrig_AfterUpdate 'write Me.codeResult Else mbLoad = False End If End Sub '------------------------------------------------------------------------------- ' cmd_Query_Click '------------------------------------------------------------------------------- Private Sub cmd_Query_Click() '200429 DoCmd.OpenQuery "qKeywordsCount" End Sub '------------------------------------------------------------------------------- ' codeOrig_AfterUpdate '------------------------------------------------------------------------------- Private Sub codeOrig_AfterUpdate() '200410-12 strive4peace, 200426-29 keywords, 211205,6 bAddBreak ' write Me.codeResult 'read lines from codeOrig 'construct string to post in codeResult with specified tags 'process one line at a time ' s4p_Keywords: read KeyWd, KeyID. write CountUsed, dtmEdit If IsNull(Me.codeOrig) Then GoTo Proc_WriteResult End If Dim db As DAO.Database _ ,rs As DAO.Recordset Dim sOrig As String _ ,sDeliLine As String _ ,sLine As String _ ,sComment As String _ ,sKeep As String _ ,sClip As String _ ,sQuote As String _ ,sLeft As String _ ,sWord As String _ ,sTagComment1 As String _ ,sTagComment2 As String _ ,sTagKeyword1 As String _ ,sTagKeyword2 As String _ ,sSQL As String _ ,bAddBreak As Boolean _ ,vResult As Variant Dim iPosComment As Integer _ ,iPosQuote1 As Integer _ ,iPosQuote2 As Integer _ ,iPosChar As Integer _ ,iLine As Integer _ ,iWord As Integer _ ,iNumKeyTag As Integer _ ,i As Integer Dim bInTag As Boolean _ ,bAllComment As Boolean _ ,bKeepGoing As Boolean Dim aLine() As String Dim aPosComment() As Integer 'position of comment or 0 Dim aAllComment() As Boolean 'true to ignore keyword processing Dim aWord() As String 'possible keywords to evaluate Dim aCharReplace() As Variant aCharReplace = Array( "(", ")", ",") Dim aCountKey() As Integer 'count how many times each keyword used iNumKeyTag = 0 'set delimiter for lines sDeliLine = vbCrLf 'initialize vResult vResult = Null With Me 'exit if code to process is blank If Nz(.codeOrig, "") = "" Then GoTo Proc_WriteResult 'code to process sOrig = .codeOrig 'set text to add before and after comment sTagComment1 = Nz(.TagComment1, "") sTagComment2 = Nz(.TagComment2, "") sTagKeyword1 = Nz(.TagKeyword1, "") sTagKeyword2 = Nz(.TagKeyword2, "") bAddBreak = .chkAddBR End With bInTag = False bAllComment = False 'split code at line breaks aLine = Split(sOrig,sDeliLine) 'for each line, track position of comment + if all comment ReDim aPosComment(UBound(aLine)) ReDim aAllComment(UBound(aLine)) '------------------------------------------------------------ COMMENTS 'process each line -- insert color code before and after comment For iLine = LBound(aLine) To UBound(aLine) sLine = aLine(iLine) bAllComment = False iPosQuote1 = 0 iPosQuote2 = 0 aPosComment(iLine) = 0 'initialize to no comment aAllComment(iLine) = False sQuote = "" 'see if there is a single quote inside the string iPosComment = InStr(sLine, "'") If iPosComment > 0 Then If Left(Trim(sLine),1) = "'" Then bAllComment = True Else 'make sure single quote isn't inside double quotes bKeepGoing = True Do While bKeepGoing 'see if there is a double quote before the single quote iPosQuote1 = InStr(Left(sLine,iPosComment), """") If iPosQuote1 > 0 Then 'see if there is a double quote after the single quote iPosQuote2 = InStr(iPosComment + 1,sLine, """") If iPosQuote2 > 0 Then 'look for another single quote after the double quote end iPosComment = InStr(iPosQuote2 + 1,sLine, "'") If Not iPosComment > 0 Then bKeepGoing = False End If Else bKeepGoing = False End If Else bKeepGoing = False End If Loop End If End If If iPosComment > 0 Then 'or bAllComment aPosComment(iLine) = iPosComment '200426 for keyword search If bInTag And Not bAllComment Then 'comment is at end of line 'end previous comment vResult = vResult & sTagComment2 bInTag = False End If If Not bInTag Then sLine = Left(sLine,iPosComment - 1) _ & sTagComment1 _ & Mid(sLine,iPosComment) bInTag = True End If Else If bInTag = True Then vResult = vResult & sTagComment2 bInTag = False End If End If aAllComment(iLine) = bAllComment vResult = (vResult + vbCrLf) & sLine Next iLine '200426 add closing tag for comment color If bInTag Then vResult = vResult & sTagComment2 bInTag = False End If '------------------------------------------------------------ KEYWORDS 'color keywords If Me.chkDoKeywords = True And Not Trim(Nz(vResult, "")) = "" Then Set db = CodeDb 'update Keywords CountUsed=0 sSQL = "UPDATE s4p_KeyWords SET CountUsed=0" With db .Execute sSQL .TableDefs.Refresh 'get max KeyID sSQL = "SELECT Max(KeyID) as MaxKeyID FROM s4p_KeyWords;" Set rs = .OpenRecordset(sSQL,dbOpenDynaset) 'Dynaset loads faster i = rs!MaxKeyID rs.Close 'load the list of keywords Set rs = .OpenRecordset( "s4p_KeyWords",dbOpenTable) End With 'set index to word text for fast looking up rs.Index = "KeyWd" 'track stats for keywords ReDim aCountKey(1 To i) 'currently 183 sOrig = vResult 'add previous tags for comments (if any) to original code vResult = Null 'reset to use again 'split code at line breaks aLine = Split(sOrig,sDeliLine) 'loop all lines again. Search for keywords before the comment (if there is one) For iLine = LBound(aLine) To UBound(aLine) 'line of code + possible tagged comment sLine = aLine(iLine) sClip = sLine 'assume the whole line is code sComment = "" 'part of line that's a comment sKeep = "" 'code with tags for color 'look for keywords if line isn't all comment or just space If Not aAllComment(iLine) And Len(Trim(sLine)) > 0 Then If aPosComment(iLine) > 0 Then 'break into code and comment If aPosComment(iLine) > 0 Then sClip = Left(sLine,aPosComment(iLine) - 1) sComment = Mid(sLine,aPosComment(iLine)) End If End If 'sClip is the code to process Do While sClip <> "" 'ignore quoted text iPosQuote1 = 1 iPosQuote2 = 0 sQuote = "" 'text in double quotes and the quotes sLeft = "" 'what is left to process after quoted text 'see if any text on the line is in quotes 'look for next double quote iPosQuote1 = InStr(iPosQuote1,sClip, """") 'if quote found, see if there is another one If iPosQuote1 > 0 Then iPosQuote2 = InStr(iPosQuote1 + 1,sClip, """") If iPosQuote2 > 0 Then 'store quoted text with quote marks sQuote = Mid(sClip,iPosQuote1,iPosQuote2 - iPosQuote1 + 1) 'get what is on the line after the quote sLeft = Mid(sClip,iPosQuote2 + 1) 'code to look for keywords sClip = Left(sClip,iPosQuote1 - 1) 'Else '-- if not found, this might be an error! End If End If If Trim(sClip) <> "" Then 'replace ( ) , with space around them For i = LBound(aCharReplace) To UBound(aCharReplace) sClip = Replace(sClip _ ,aCharReplace(i) _ , " " & aCharReplace(i) & " " _ ) Next i 'break words at spaces aWord = Split(sClip, " ") 'now the we have words, construct sClip to have tags too sClip = "" 'loop through words in the clip For iWord = LBound(aWord) To UBound(aWord) sWord = aWord(iWord) If Trim(sWord) <> "" Then 'see if word is a keyword rs.Seek "=",sWord If Not rs.NoMatch Then 'add tags around keyword sWord = TagKeyword1 & sWord & TagKeyword2 'increase count for keyword aCountKey(rs!KeyID) = aCountKey(rs!KeyID) + 1 'number of keywords tagged iNumKeyTag = iNumKeyTag + 1 End If End If 'add word and space to clip sClip = sClip & sWord & IIf(sWord <> ",", " ",Null) Next iWord 'word End If 'sClip <> "" 'add tagged clip and possible quote to Keep sKeep = sKeep & sClip & sQuote 'reset Quote since we got it sQuote = "" 'new clip is whatever is left sClip = sLeft Loop ' while sClip <> "" 'remove extra spaces For i = LBound(aCharReplace) To UBound(aCharReplace) sKeep = Replace(sKeep _ , " " & aCharReplace(i) & " " _ ,aCharReplace(i)) Next i 'remove extra tags, for instance between As and String sKeep = Replace(sKeep,sTagKeyword2 & " " & sTagKeyword1, " ") sLine = sKeep & sComment 'redefine sLine to include tags sKeep = "" End If 'not all comment '211205 option only used for HTML If bAddBreak Then sLine = sLine & "
" End If 'write newly tagged (or not) line to the result vResult = (vResult + vbCrLf) & sLine keyword__NextLine: Next iLine 'keyword stats If iNumKeyTag > 0 Then 'write keywords and count times used to debug window With rs rs.Index = "PrimaryKey" For i = LBound(aCountKey) To UBound(aCountKey) If aCountKey(i) > 0 Then .Seek "=",i If Not .NoMatch Then .Edit !CountUsed = aCountKey(i) !dtmEdit = Now .Update End If End If Next i End With 'rs End If 'keyword stats End If 'chkDoKeywords=true and has result 'write result to form With Me vResult = (.TagCode1 + vResult + .TagCode2 _ + vbCrLf + vbCrLf _ + "' Made with Color Code add-in posted on http://msaccessgurus.com/tool/Addin_ColorCode.htm" _ ) & "" End With Proc_WriteResult: Me.codeResult = vResult & "" Proc_Exit: On Error Resume Next If Not rs Is Nothing Then rs.Close Set rs = Nothing End If Set db = Nothing Exit Sub Proc_Err: MsgBox Err.Description _ ,, "ERROR " & Err.Number _ & " codeOrig_AfterUpdate : " & Me.Name Resume Proc_Exit 'if you BREAK MsgBox, you can set this to be next statement: Resume End Sub '------------------------------------------------------------------------------- ' cmd_Copy2Clipboard_Click '------------------------------------------------------------------------------- Private Sub cmd_Copy2Clipboard_Click() '200411 strive4peace 'copy result code to the clipboard Dim sCode As String With Me.codeResult If Nz(.Value, "") = "" Then Exit Sub sCode = .Value End With 'MSForms.DataObject With CreateObject( "new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") .SetText sCode .PutInClipboard End With MsgBox "Press Ctrl-V to paste code with tags where you want it",, "Done" End Sub '------------------------------------------------------------------------------- ' cmd_SaveFile_Click '------------------------------------------------------------------------------- Private Sub cmd_SaveFile_Click() '200429 strive4peace 'CALLS ' SaveStringAsFile Dim sPathFile As String _ ,sExtension As String sExtension = Nz(Me.SetID.Column(9), "txt") If sExtension = "" Then sExtension = "txt" sPathFile = CurrentProject.Path & "\ColorCode_Result." & sExtension With Me.codeResult If Nz(.Value, "") <> "" Then Call SaveStringAsFile(sPathFile,.Value) Else MsgBox "No tagged code to save", "Nothing to do" Exit Sub End If End With If MsgBox(sPathFile & " was created. Open it?" _ ,vbYesNo, "Done with Color Code. Tags added") = vbNo Then Exit Sub Application.FollowHyperlink sPathFile End Sub '------------------------------------------------------------------------------- ' cmd_SetSubDatasheetNone_Click '------------------------------------------------------------------------------- Private Sub cmd_SetSubDatasheetNone_Click() '200430 s4p. Not needed to color code -- just an extra button in form footer Call SetSubDatasheetNone End Sub ' You may freely use and share this code ' provided this license notice and comment lines are not changed; ' code may be modified provided you clearly note your changes. ' You may not sell this code alone, or as part of a collection, ' without my handwritten permission. ' All ownership rights reserved. Use at your own risk. ' ~ crystal (strive4peace) www.msaccessgurus.com '*************** Code End *******************************************************
This add-in is a regular ACCDB file that has been renamed to have an ACCDA extension. It may be used freely, but you may not sell it in whole or in part. You may include it in applications you develop for others provided you pass on the download link and share the source code and designs with your modifications.
To make it easier to post VBA with colors on web pages, I wrote a little tool in Access. Access World forums is one of the forums that supports CODE tags with rich text ... so I posted a tool to color comments green. MickJav wanted the keywords blue too ... with a little modification, I added keyword coloring and made it an add-in too!
Choose tags for BBCode or HTML. There are actually a few HTML sets, and you can make more if you want by modifying data in the table for sets.
I used the ColorCode add-in to format the code for posting on this web page :) Now its quick to post code that's colored.
Email me! I love hearing about what you're doing with Access, how you're using tools and code you download from MsAccessGurus, and videos that you like YouTube.
Are you a developer? Do you want to share? Email to ask about getting your pages added to the code or tools index.
When we communicate, collaborate, and appreciate, we all get better. Thank you.
Let's connect and team-develop while we build your application together. As needed, I'll pull in code and features from my vast libraries, cutting out lots of development time. I get inspired when we work together, and you get a great application ... win-win!
Email me anytime at info@msAccessGurus